home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok11 / r.o.m. / m2sources / formelauswertung.mod < prev    next >
Text File  |  1993-11-04  |  23KB  |  804 lines
  1. IMPLEMENTATION MODULE Formelauswertung;
  2. (*
  3.   Created:   17.11.87
  4.   Changed:   10.02.88/26.8.88/29.9.881/10/88 by 
  5.              Stefan Salewski
  6.              Stolper Weg 3
  7.              2160 Stade   West-Germany
  8.              Tel: 04141/61130
  9.   Note: compiled with AMIGA Modula-2 System by AMSoft Version from 5.5.88
  10.    
  11. *)
  12.   FROM Arts IMPORT Error;
  13.   FROM MyLongRealConversions IMPORT StrToReal;
  14.   FROM MathTrans IMPORT Fieee,Tieee;
  15.   FROM MyMathTrans IMPORT Abs,Fac,Sqr,Power,TAN,Cot,Sec,
  16.     Cosec,Arcsin,Arccos,Arccot,EXP,Ln,LOG,SIN,COS,Arctan,SINH,Arcoth,Int,
  17.     COSH,TANH,Coth,Arsinh,Arcosh,Artanh,SQRT;
  18.   FROM MyMathLibLong IMPORT abs,fac,sqr,power,tan,cot,sec,
  19.     cosec,arcsin,arccos,arccot,exp,ln,log,sin,cos,arctan,arcoth,int,
  20.     sinh,cosh,tanh,coth,arsinh,arcosh,artanh,sqrt,
  21.     errorNumber;
  22.   FROM Strings IMPORT Insert,Occurs,Delete;
  23.   FROM MyStrings IMPORT Assign,Length;
  24.   FROM MyUties IMPORT Buchstabe,Operator,AddOp,IsADigit;
  25.   FROM SYSTEM IMPORT FFP,ADR;
  26. (*
  27.   Der Bereich Char(1) bis Char(AnzFktn) dient zur Speicherung von
  28.   Funktionssymbolen. z.B. arcsin=Char(1); sin=Char(18) usw.
  29.   
  30.   Char(58) bis Char(64) entspricht +,-,*,/,^,(,)
  31.   
  32.   Der Bereich 'A' .. 'z' enthaelt die Werte der definierten Variablen.
  33.   
  34.   Zeichen groesser 127 symbolisieren die Zahlen in der Formel
  35.   
  36.   Nach anwendung von DefFormel enthalt die Formel also nur noch Variablen(A..z),
  37.   Zahlen(Char(128)..Char(255)), Funktionsymbole(Char(0)..Char(AnzFktn-1)
  38.   und Plus,Minus,Mal,Durch,Hoch,Bra,Ket.
  39. *)
  40.   CONST
  41.     MaxLongReal=MAX(LONGREAL);
  42.     MaxFFP=MAX(FFP);
  43.     Plus=CHAR(58);
  44.     Minus=CHAR(59);
  45.     Mal=CHAR(60);
  46.     Durch=CHAR(61);
  47.     Hoch=CHAR(62);
  48.     Bra=CHAR(63);
  49.     Ket=CHAR(64);
  50.     AnzFktn=26;   (* sin,cos...                            *)
  51.     ErsteZahl=CHAR(128);
  52.     LetzteZahl=CHAR(255);
  53.     FirstPos=128; (* Position des ersten zur Zahlenspeicherung            *)
  54.                   (* verwendeten Zeichens
  55.                      Die erste Zahl in der Formel wird ersetzt durch CHAR(128),
  56.                      die zweite durch Char(129) usw bis maximal Char(255).
  57.                      Gleichzeitig bekommt Char(128) den Zahlenwert der ersten
  58.                      Zahl zugewiesen usw.
  59.                    *)
  60.  
  61.   TYPE
  62.     Zahlen=[ErsteZahl..LetzteZahl];
  63.     FktnStr=ARRAY[0..6] OF CHAR;
  64.     FFPFunktion=PROCEDURE(FFP):FFP;
  65.     LongFunktion=PROCEDURE(LONGREAL):LONGREAL;
  66.     Position=[0..StrLength-1];
  67.   VAR
  68.     zahlenspeicherLong:ARRAY Formelnummer,Zahlen OF LONGREAL;
  69.     zahlenspeicherFFP:ARRAY Formelnummer,Zahlen OF FFP;
  70.     formeln:ARRAY Formelnummer OF Formelstring;
  71.     (*length:ARRAY Formelnummer OF CARDINAL;*)
  72.     belegt:ARRAY['A'..'z'] OF BOOLEAN;
  73.     funktionen:ARRAY[1..AnzFktn] OF FktnStr;
  74. (**********************************************************************)
  75.   PROCEDURE Init;
  76.     VAR c: CHAR;
  77.   BEGIN
  78.     FOR c:='A' TO 'z' DO
  79.       belegt[c]:=FALSE
  80.     END;
  81.     funktionen[1]:='arcsin';
  82.     funktionen[2]:='arccos';
  83.     funktionen[3]:='arctan'; 
  84.     funktionen[4]:='arsinh';
  85.     funktionen[5]:='arcosh';
  86.     funktionen[6]:='artanh';
  87.     funktionen[7]:='arcoth';
  88.     funktionen[8]:='arccot';
  89.     funktionen[9]:='cosec';
  90.     funktionen[10]:='sinh';
  91.     funktionen[11]:='cosh';
  92.     funktionen[12]:='tanh';
  93.     funktionen[13]:='coth';
  94.     funktionen[14]:='sqrt';
  95.     funktionen[15]:='sqr';
  96.     funktionen[16]:='cot';
  97.     funktionen[17]:='sec';
  98.     funktionen[18]:='sin';
  99.     funktionen[19]:='cos';
  100.     funktionen[20]:='tan';
  101.     funktionen[21]:='log';
  102.     funktionen[22]:='exp';
  103.     funktionen[23]:='fac';
  104.     funktionen[24]:='abs';
  105.     funktionen[25]:='int';
  106.     funktionen[26]:='ln';
  107.   END Init;
  108. (**********************************************************************)
  109.   PROCEDURE SoS(c:CHAR):BOOLEAN;
  110.   BEGIN
  111.     RETURN (c<=CHAR(AnzFktn)) AND (c#0C)
  112.   END SoS;
  113.   PROCEDURE Zahl(c:CHAR):BOOLEAN;
  114.   BEGIN
  115.     RETURN (c>CHAR(127)) OR ((c>='A') AND (c<='z'));
  116.   END Zahl;
  117.   PROCEDURE Gueltig(c:CHAR):BOOLEAN;
  118.   BEGIN
  119.     RETURN IsADigit(c) OR (Buchstabe(c)  OR Operator(c) OR (c='(') OR (c=')')
  120.        OR (c='.'))
  121.   END Gueltig;
  122.   PROCEDURE ASet(c:CHAR):BOOLEAN;
  123.   BEGIN
  124.     RETURN ((c>=Plus) AND (c<=Hoch)) OR (c=Ket)
  125.   END ASet; 
  126.   PROCEDURE CSet(c:CHAR):BOOLEAN;
  127.   BEGIN
  128.     RETURN (Zahl(c))  OR (c=Ket)
  129.   END CSet;
  130.   PROCEDURE DSet(c:CHAR):BOOLEAN;
  131.   BEGIN
  132.     RETURN (Zahl(c) OR (c=Bra) OR SoS(c))
  133.   END DSet;
  134.   
  135.   PROCEDURE FormelOK(VAR str:Formelstring):BOOLEAN;
  136.     VAR kl:INTEGER;
  137.       i,l:CARDINAL;
  138.   BEGIN
  139.     l:=Length(str)-1;
  140.     FOR i:=0 TO l DO
  141.       IF NOT Gueltig(str[i]) THEN RETURN FALSE END
  142.     END;
  143.     kl:=0;
  144.     FOR i:=0 TO l DO
  145.       IF str[i]='(' THEN
  146.         INC(kl)
  147.       ELSIF str[i]=')' THEN
  148.         DEC(kl)
  149.       END;
  150.       IF kl<0 THEN
  151.         RETURN FALSE
  152.       END
  153.     END;
  154.     RETURN kl=0
  155.   END FormelOK;
  156.  
  157.   PROCEDURE SyntaxOK(VAR str:Formelstring):BOOLEAN;
  158.     VAR i,len: CARDINAL;
  159.       ok:BOOLEAN;
  160.   BEGIN
  161.     i:=0;
  162.     ok:=TRUE;
  163.     IF (str[i]=Ket) OR (str[i]=0C) OR (str[i]=Mal) OR (str[i]=Durch)
  164.         OR (str[i]=Hoch) THEN
  165.       RETURN FALSE
  166.     ELSE
  167.       len:=Length(str)-1;
  168.       WHILE (i<len) AND ok DO
  169.         IF str[i]=Bra THEN
  170.           ok:=(str[i+1]#Ket) AND (str[i+1]#Mal) AND (str[i+1]#Durch)
  171.                    AND (str[i+1]#Hoch)
  172.         ELSIF (str[i]=Ket) OR Zahl(str[i]) THEN
  173.           ok:=ASet(str[i+1])
  174.         ELSIF SoS(str[i]) THEN
  175.           ok:=(str[i+1]=Bra)
  176.         ELSIF (str[i]>=Plus) AND (str[i]<=Hoch) THEN
  177.           ok:=DSet(str[i+1])
  178.         ELSE
  179.           RETURN FALSE;
  180.         END;
  181.         INC(i);
  182.       END;
  183.     END;
  184.     IF NOT ok THEN
  185.       RETURN FALSE
  186.     ELSE
  187.       RETURN CSet(str[i])
  188.     END;
  189.   END SyntaxOK;
  190.         
  191.   PROCEDURE AssignLong(c:CHAR;x:LONGREAL):BOOLEAN;
  192.   BEGIN
  193.     IF (c>='A') AND (c<='z') THEN
  194.       varListLong[c]:=x;
  195.       varListFFP[c]:=Fieee(REAL(x));
  196.       belegt[c]:=TRUE;
  197.       RETURN TRUE
  198.     ELSE
  199.       RETURN FALSE
  200.     END;
  201.   END AssignLong;
  202.   
  203.   PROCEDURE AssignFFP(c:CHAR;x:FFP):BOOLEAN;
  204.   BEGIN
  205.     IF (c>='A') AND (c<='z') THEN
  206.       varListLong[c]:=LONGREAL(Tieee(x));
  207.       varListFFP[c]:=x;
  208.       belegt[c]:=TRUE;
  209.       RETURN TRUE
  210.     ELSE
  211.       RETURN FALSE
  212.     END;
  213.   END AssignFFP;
  214.   
  215.   PROCEDURE ClearVar(c:CHAR);
  216.   BEGIN
  217.     IF Buchstabe(c) THEN
  218.       belegt[c]:=FALSE
  219.     END
  220.   END ClearVar;
  221. (**********************************************************************)
  222.   PROCEDURE GetLongValue(c:CHAR;VAR x:LONGREAL):BOOLEAN;
  223.   BEGIN
  224.     IF Buchstabe(c) AND belegt[c] THEN
  225.       x:=varListLong[c];
  226.       RETURN TRUE
  227.     ELSE
  228.       RETURN FALSE
  229.     END
  230.   END GetLongValue;
  231.   (**********************************************************************)
  232.   PROCEDURE GetFFPValue(c:CHAR;VAR x:FFP):BOOLEAN;
  233.   BEGIN
  234.     IF Buchstabe(c) AND belegt[c] THEN
  235.       x:=varListFFP[c];
  236.       RETURN TRUE
  237.     ELSE
  238.       RETURN FALSE
  239.     END
  240.   END GetFFPValue;
  241. (**********************************************************************)
  242.   PROCEDURE SetBrackets(VAR str:ARRAY OF CHAR):BOOLEAN;
  243.     TYPE StrPos=[0..StrLength-1];
  244.     VAR i,leftpos,rightpos,laenge:StrPos;
  245.       lok:BOOLEAN;
  246.       string:Formelstring;
  247.       hi:CARDINAL;
  248.     PROCEDURE Testelinks(c1,c2,c3,c4:CHAR;i:StrPos;
  249.                          VAR bPos:StrPos;VAR noetig:BOOLEAN);
  250.       VAR j: StrPos;
  251.       PROCEDURE Jumpleft;
  252.       BEGIN
  253.         REPEAT
  254.           DEC(j);
  255.           IF string[j]=Ket THEN
  256.             Jumpleft
  257.           END;
  258.         UNTIL string[j]=Bra;
  259.         IF j>0 THEN
  260.           DEC(j)
  261.         END;
  262.       END Jumpleft;
  263.     BEGIN (* Testelinks *)
  264.       j:=i;
  265.       REPEAT
  266.         DEC(j);
  267.         IF string[j]=Ket THEN
  268.           Jumpleft
  269.          END;
  270.         noetig:=(string[j]=c1) OR (string[j]=c3) OR (string[j]=c2) OR
  271.           (string[j]=c4);
  272.       UNTIL noetig OR (string[j]=Bra) OR (j=0);
  273.       noetig:=noetig AND (j#0);
  274.   (*noetig:=noetig AND NOT ((j=0) AND ((string[0]=Plus) OR (string[i]=Minus));*)
  275.   (*    noetig:=noetig AND NOT((i>1) AND ((string[j])=Plus) OR
  276.             (string[j]=Minus) AND (string[j-1]='E') AND IsADigit(string[j-2])); 
  277.    *)
  278.       bPos:= j+1;
  279.     END Testelinks;
  280.  
  281.     PROCEDURE Testerechts(c1,c2,c3,c4:CHAR;i:StrPos;
  282.                           VAR bPos:StrPos);
  283.       VAR j,strLaenge: StrPos;
  284.         gesucht:BOOLEAN;
  285.       PROCEDURE Jumpright;
  286.       BEGIN
  287.         REPEAT
  288.           INC(j);
  289.           IF string[j]=Bra THEN
  290.             Jumpright
  291.           END;
  292.         UNTIL string[j]=Ket;
  293.         INC(j);
  294.       END Jumpright;
  295.     BEGIN
  296.       strLaenge:=Length(string);
  297.       j:=i;
  298.       REPEAT
  299.         INC(j);
  300.         IF string[j]=Bra THEN
  301.           Jumpright
  302.         END;
  303.         gesucht:=(string[j]=c1) OR (string[j]=c3) OR (string[j]=c2) OR
  304.                  (string[j]=c4);
  305.       UNTIL (j>=strLaenge) OR gesucht OR (string[j]=Ket);
  306.       bPos:=j;
  307.       IF j=strLaenge THEN
  308.         INC(bPos)
  309.       END;
  310.     END Testerechts;
  311.  
  312.     PROCEDURE Set(lk,rk:StrPos);
  313.     (* Setzt Klammern an die Positionen lk und rk *)
  314.     BEGIN
  315.       Insert(string,lk,Bra);
  316.       IF rk=Length(string) THEN
  317.         string[rk]:=Ket;
  318.         string[rk+1]:=0C
  319.       ELSE
  320.         Insert(string,rk+1,Ket)
  321.       END;
  322.     END Set;
  323.   BEGIN
  324.     hi:=HIGH(str);
  325.     laenge:=Length(str);
  326.     IF laenge< StrLength-1 THEN
  327.       Assign(string,str);
  328.       string[laenge]:=0C;
  329.       string[laenge+1]:=0C;
  330.       string[laenge+2]:=0C;
  331.       i:=0;
  332.       REPEAT 
  333.         IF string[i]=Hoch THEN
  334.           Testelinks(Mal,Durch,Plus,Minus,i,leftpos,lok);
  335.           IF lok THEN
  336.           Testerechts(Mal,Durch,Plus,Minus,i,rightpos);
  337.        (*   IF lok THEN *)
  338.             Set(leftpos,rightpos);
  339.             INC(laenge,2)
  340.            END
  341.         END;
  342.         INC(i);
  343.       UNTIL (i=laenge) OR (laenge>hi);
  344.       IF laenge>hi THEN 
  345.         RETURN FALSE
  346.       END;
  347.       i:=0;
  348.       REPEAT
  349.         IF (string[i]=Mal) OR (string[i]=Durch) THEN
  350.           Testelinks(Plus,Plus,Minus,Minus,i,leftpos,lok);
  351.           IF lok THEN
  352.           Testerechts(Plus,Plus,Minus,Minus,i,rightpos);
  353.           (* IF lok THEN *)
  354.             Set(leftpos,rightpos);
  355.             INC(laenge,2)
  356.           END
  357.         END;
  358.         INC(i);
  359.       UNTIL (i=laenge) OR (laenge>hi);
  360.       IF laenge>hi THEN 
  361.         RETURN FALSE
  362.       END;
  363.       Assign(str,string);
  364.       RETURN TRUE
  365.     ELSE
  366.       RETURN FALSE
  367.     END;
  368.   END SetBrackets;
  369. (**********************************************************************)
  370.   PROCEDURE FFPBerechnung(nummer:Formelnummer;
  371.               VAR ergebnis:FFP;
  372.                       VAR fehlernummer:CARDINAL);
  373.     VAR pos: CARDINAL;
  374.       ch:CHAR;
  375.       
  376.     PROCEDURE Ausdruck():FFP; FORWARD;
  377.     PROCEDURE Neuezahl():FFP;
  378.       VAR helpChr:CHAR;
  379.     BEGIN
  380.       IF formeln[nummer,pos]=Bra THEN
  381.         INC(pos);
  382.         RETURN Ausdruck()
  383.       ELSE
  384.         helpChr:=formeln[nummer,pos];
  385.         INC(pos);
  386.         IF (helpChr>='A') AND (helpChr<='z') THEN
  387.       RETURN varListFFP[helpChr]
  388.         ELSE
  389.       RETURN zahlenspeicherFFP[nummer,helpChr]
  390.         END
  391.       END
  392.     END Neuezahl;
  393.  
  394.     PROCEDURE Ausdruck():FFP;
  395.       VAR func:FFPFunktion;
  396.         oper:CHAR;
  397.         argument,ergebnis:FFP;
  398.     BEGIN
  399.       ergebnis:=0.0;
  400.       WHILE (formeln[nummer,pos]#Ket) AND (formeln[nummer,pos]#0C)
  401.                                       AND (errorNumber=0) DO
  402.         IF (formeln[nummer,pos]>=Plus) AND (formeln[nummer,pos]<=Hoch) THEN
  403.           oper:=formeln[nummer,pos];
  404.           INC(pos)
  405.         ELSE
  406.           oper:=Plus
  407.         END;
  408.         IF formeln[nummer,pos]<=CHAR(AnzFktn) THEN (* Funktionsberechnung *)
  409.           CASE formeln[nummer,pos] OF
  410.             01C:func:=Arcsin|
  411.             02C:func:=Arccos|
  412.             03C:func:=Arctan|
  413.             04C:func:=Arsinh|
  414.             05C:func:=Arcosh|
  415.             06C:func:=Artanh|
  416.             07C:func:=Arcoth|
  417.             10C:func:=Arccot|
  418.             11C:func:=Cosec|
  419.             12C:func:=SINH|
  420.             13C:func:=COSH|
  421.             14C:func:=TANH|
  422.             15C:func:=Coth|
  423.             16C:func:=SQRT|
  424.             17C:func:=Sqr|
  425.             20C:func:=Cot|
  426.             21C:func:=Sec|
  427.             22C:func:=SIN|
  428.             23C:func:=COS|
  429.             24C:func:=TAN|
  430.             25C:func:=LOG|
  431.             26C:func:=EXP|
  432.             27C:func:=Fac|
  433.             30C:func:=Abs|
  434.             31C:func:=Int|
  435.             32C:func:=Ln|
  436.           ELSE
  437.             Error(ADR('FFPBerechnung'),ADR('Case Formel... Error'))
  438.           END;(* Case *)
  439.           INC(pos);
  440.           argument:=func(Neuezahl());
  441.         ELSE
  442.           argument:=Neuezahl();
  443.         END;
  444.         IF errorNumber=0 THEN
  445.           CASE oper OF
  446.             Plus:ergebnis:=ergebnis+argument;
  447.                 IF ABS(ergebnis)>=MaxFFP THEN
  448.                   errorNumber:=104
  449.                 END|
  450.             Minus:ergebnis:=ergebnis-argument;
  451.                 IF ABS(ergebnis)>=MaxFFP THEN
  452.                   errorNumber:=105
  453.                 END|
  454.             Hoch:ergebnis:=Power(ergebnis,argument)|
  455.             Mal:ergebnis:=ergebnis*argument;
  456.                 IF ABS(ergebnis)>=MaxFFP THEN
  457.                   errorNumber:=103
  458.                 END|
  459.             Durch:IF argument=0.0 THEN
  460.                   errorNumber:=101
  461.                 ELSE
  462.                   ergebnis:=ergebnis/argument;
  463.                   IF ABS(ergebnis)>=MaxFFP THEN
  464.                     errorNumber:=102 (*overflov*)
  465.                   END;
  466.                 END|
  467.             ELSE
  468.               Error(ADR('FFPBerechnung'),ADR('Operator... Error'))
  469.           END
  470.         END
  471.       END;
  472.       IF formeln[nummer,pos]=Ket THEN INC(pos);END;
  473.       RETURN ergebnis
  474.     END Ausdruck;
  475.   BEGIN (* Auswertung *)
  476.     IF formeln[nummer,0]#0C THEN
  477.       pos:=0;
  478.       errorNumber:=0;
  479.       ergebnis:=Ausdruck();
  480.       fehlernummer:=errorNumber
  481.     ELSE
  482.       ergebnis:=0.0;
  483.       fehlernummer:=31
  484.     END
  485.   END FFPBerechnung;
  486. (**********************************************************************)
  487.   PROCEDURE LongBerechnung(nummer:Formelnummer;
  488.                    VAR ergebnis:LONGREAL;
  489.                            VAR fehlernummer:CARDINAL);
  490.     VAR
  491.       pos: CARDINAL;
  492.       ch:CHAR;
  493.       
  494.     PROCEDURE Ausdruck():LONGREAL; FORWARD;
  495.     PROCEDURE Neuezahl():LONGREAL;
  496.       VAR helpChr:CHAR;
  497.     BEGIN
  498.       IF formeln[nummer,pos]=Bra THEN
  499.         INC(pos);
  500.         RETURN Ausdruck()
  501.       ELSE
  502.         helpChr:=formeln[nummer,pos];
  503.         INC(pos);
  504.         IF (helpChr>='A') AND (helpChr<='z') THEN
  505.       RETURN varListLong[helpChr]
  506.         ELSE
  507.       RETURN zahlenspeicherLong[nummer,helpChr]
  508.         END
  509.       END
  510.     END Neuezahl;
  511.  
  512.     PROCEDURE Ausdruck():LONGREAL;
  513.       VAR func: LongFunktion;
  514.         oper: CHAR;
  515.         argument,ergebnis:LONGREAL;
  516.     BEGIN
  517.       ergebnis:=0.0;
  518.       WHILE (formeln[nummer,pos]#Ket) AND (formeln[nummer,pos]#0C)
  519.                                       AND (errorNumber=0) DO
  520.         IF (formeln[nummer,pos]>=Plus) AND (formeln[nummer,pos]<=Hoch) THEN
  521.           oper:=formeln[nummer,pos];
  522.           INC(pos)
  523.         ELSE
  524.           oper:=Plus
  525.         END;
  526.         IF formeln[nummer,pos]<=CHAR(AnzFktn) THEN (* Funktionsberechnung *)
  527.           CASE formeln[nummer,pos] OF
  528.             01C:func:=arcsin|
  529.             02C:func:=arccos|
  530.             03C:func:=arctan|
  531.             04C:func:=arsinh|
  532.             05C:func:=arcosh|
  533.             06C:func:=artanh|
  534.             07C:func:=arcoth|
  535.             10C:func:=arccot|
  536.             11C:func:=cosec|
  537.             12C:func:=sinh|
  538.             13C:func:=cosh|
  539.             14C:func:=tanh|
  540.             15C:func:=coth|
  541.             16C:func:=sqrt|
  542.             17C:func:=sqr|
  543.             20C:func:=cot|
  544.             21C:func:=sec|
  545.             22C:func:=sin|
  546.             23C:func:=cos|
  547.             24C:func:=tan|
  548.             25C:func:=log|
  549.             26C:func:=exp|
  550.             27C:func:=fac|
  551.             30C:func:=abs|
  552.             31C:func:=int|
  553.             32C:func:=ln|
  554.           ELSE
  555.             Error(ADR('LongBerechnung'),ADR('Case Formel... Error'))
  556.           END;(* Case *)
  557.           INC(pos);
  558.           argument:=func(Neuezahl());
  559.         ELSE
  560.           argument:=Neuezahl();
  561.         END;
  562.         IF errorNumber=0 THEN
  563.           CASE oper OF
  564.             Plus:ergebnis:=ergebnis+argument;
  565.                 IF ABS(ergebnis)>=MaxLongReal THEN
  566.                   errorNumber:=104
  567.                 END|
  568.             Minus:ergebnis:=ergebnis-argument;
  569.                 IF ABS(ergebnis)>=MaxLongReal THEN
  570.                   errorNumber:=105
  571.                 END|
  572.             Hoch:ergebnis:=power(ergebnis,argument)|
  573.             Mal:ergebnis:=ergebnis*argument;
  574.                 IF ABS(ergebnis)>=MaxLongReal THEN
  575.                   errorNumber:=103
  576.                 END|
  577.             Durch:IF argument=0.0 THEN
  578.                     errorNumber:=101
  579.                   ELSE
  580.                     ergebnis:=ergebnis/argument;
  581.                     IF ABS(ergebnis)>=MaxLongReal THEN
  582.                       errorNumber:=102 (*overflov*)
  583.                     END
  584.                   END|
  585.           ELSE
  586.             Error(ADR('LongBerechnung'),ADR('Operator... Error'))
  587.           END
  588.         END
  589.       END;
  590.       IF formeln[nummer,pos]=Ket THEN INC(pos) END;
  591.       RETURN ergebnis
  592.     END Ausdruck;
  593.   BEGIN (* Auswertung *)
  594.     IF formeln[nummer,0]#0C THEN
  595.       pos:=0;
  596.       errorNumber:=0;
  597.       ergebnis:=Ausdruck();
  598.       fehlernummer:=errorNumber
  599.     ELSE
  600.       ergebnis:=0.0;
  601.       fehlernummer:=31
  602.     END
  603.   END LongBerechnung;
  604. (**********************************************************************)
  605.   PROCEDURE DefFormel(nummer:Formelnummer;VAR str:ARRAY OF CHAR;
  606.                       korrekt,onlyLong:BOOLEAN):CARDINAL;
  607.     VAR
  608.       testStr:Formelstring; 
  609.       i,soOft:CARDINAL;
  610.       synOK,vD:BOOLEAN;
  611.       fehlernummer:CARDINAL;
  612.       zeichen:CHAR;
  613.     PROCEDURE VarDef(VAR str:Formelstring):BOOLEAN;
  614.       VAR i:CARDINAL;
  615.     BEGIN
  616.       FOR i:=0 TO Length(str)-1 DO
  617.         IF ((str[i]>='A') AND (str[i]<='z')) AND NOT belegt[str[i]] THEN
  618.           RETURN FALSE
  619.         END
  620.       END;
  621.       RETURN TRUE;
  622.     END VarDef;
  623.  
  624.     PROCEDURE Transform(VAR str:Formelstring;VAR wieOft:CARDINAL):BOOLEAN;
  625.     (* Substituiert Zahlen im String durch Zeichen
  626.        und weist den entsprechenden Feldvariablen den Zahlenwert zu        *)
  627.     (* 7.98 ==> CHAR(128); zahlenspeicherLong[Char(128)]:=7.98             *)
  628.       VAR
  629.         i,zahllaenge:Position;
  630.         x:LONGREAL;
  631.         zeichen:CHAR;
  632.         help: ARRAY[0..0] OF CHAR;
  633.         vorzZahlmoegl,getOK: BOOLEAN;
  634.  
  635.       PROCEDURE GetNumber(pos:Position; VAR l:Position;VAR x:LONGREAL):BOOLEAN;
  636.       (* weist den Wert der Zahl, die an der Position pos im String Str
  637.          Steht und l Zeichen lang ist x zu                                 *)
  638.         VAR s:Formelstring;
  639.           k,i:CARDINAL;
  640.           error,zifORadop:BOOLEAN;
  641.       BEGIN
  642.         error:=FALSE;
  643.         i:=pos;
  644.         l:=0;
  645.         IF (str[i]='+') OR (str[i]='-')  THEN
  646.           s[0]:=str[i];
  647.           INC(l)
  648.         END;
  649.         WHILE IsADigit(str[i+l]) DO
  650.           s[l]:=str[i+l];
  651.           INC(l)
  652.         END;
  653.         IF str[i+l] ='.' THEN
  654.           s[l]:=str[i+l];
  655.           INC(l);
  656.           WHILE IsADigit(str[i+l]) DO
  657.             s[l]:=str[i+l];
  658.             INC(l);
  659.           END
  660.         END;
  661.         IF str[i+l]='E' THEN
  662.           zifORadop:=IsADigit(str[i+1+l]) OR (AddOp(str[i+1+l]) AND 
  663.             IsADigit(str[i+2+l]));
  664.           IF zifORadop THEN
  665.             s[l]:= str[i+l];
  666.             INC(l);
  667.             IF AddOp(str[i+l]) THEN
  668.               s[l]:=str[i+l];INC(l)
  669.             END;
  670.             k:=0;
  671.             WHILE IsADigit(str[i+l]) AND (k<3) DO
  672.               s[l]:= str[i+l];
  673.               INC(l);
  674.               INC(k);
  675.             END;
  676.             onlyLong:=(k=3) OR ((k=2) AND NOT((s[l-2]='0') OR (s[l-2]='1')));
  677.             error:= (k<3) OR ((k=3) AND ((s[l-3]='0') OR (s[l-3]='1') OR 
  678.               (s[l-3]='2')));
  679.             error:=NOT error
  680.           END
  681.         END;
  682.         s[l]:=0C;
  683.         IF NOT error THEN
  684.           StrToReal(s,x,error)
  685.         END;
  686.         RETURN NOT error
  687.       END GetNumber;
  688.     BEGIN (* Transform*)
  689.       i:=0;
  690.       wieOft:=0;
  691.       getOK:=TRUE;
  692.       WHILE (i<=Length(str)) AND getOK DO
  693.         vorzZahlmoegl:=(i=0) OR (str[i-1]='(');
  694.         IF IsADigit(str[i]) OR (AddOp(str[i]) AND vorzZahlmoegl AND
  695.            IsADigit(str[i+1])) THEN
  696.           getOK:=GetNumber(i,zahllaenge,x);
  697.           IF getOK THEN
  698.             zeichen:=CHR(FirstPos+wieOft);
  699.             zahlenspeicherLong[0,zeichen]:=x;
  700.             Delete(str,i,zahllaenge);
  701.             help[0]:= CHR(FirstPos+wieOft);
  702.             IF i= Length(str) THEN
  703.               str[i]:=help[0];
  704.               str[i+1]:=0C
  705.             ELSE
  706.               Insert(str,i,help)
  707.             END;
  708.             INC(wieOft)
  709.           END
  710.         END;
  711.         INC(i)
  712.       END;
  713.       RETURN getOK
  714.     END Transform;
  715.     PROCEDURE Substitute(VAR str:Formelstring);
  716.       VAR i: CARDINAL;
  717.         position:INTEGER;
  718.         s:ARRAY[0..1] OF CHAR;
  719.     BEGIN
  720.       s[1]:=0C;
  721.       FOR i:=1 TO AnzFktn DO
  722.         position:=0;
  723.         REPEAT
  724.           position:=Occurs(str,position,funktionen[i],TRUE);
  725.           IF position#-1 THEN
  726.             Delete(str,position,Length(funktionen[i]));
  727.             s[0]:=CHAR(i);
  728.             Insert(str,position,s);
  729.             INC(position)
  730.           END
  731.         UNTIL position=-1
  732.       END
  733.     END Substitute;
  734.   BEGIN
  735.     IF (str[0]#0C) AND (HIGH(str)<=StrLength) AND (Length(str)<StrLength-2) THEN
  736.       Assign(testStr,str);
  737.       fehlernummer:=Length(str);
  738.       testStr[fehlernummer]:=0C;
  739.       testStr[fehlernummer+1]:=0C;
  740.       testStr[fehlernummer+2]:=0C;
  741.       fehlernummer:=0; (* Kein Fehler *)
  742.       IF FormelOK(testStr) THEN
  743.         (* Substitute und Transform arbeiten noch mit +,-,...),
  744.            danach wird mit Plus,....Ket gearbeitet
  745.         *)
  746.         Substitute(testStr);
  747.         IF Transform(testStr,soOft) THEN
  748.           FOR i:=0 TO Length(testStr)-1 DO
  749.             CASE testStr[i] OF
  750.               '+':testStr[i]:=Plus|
  751.               '-':testStr[i]:=Minus|
  752.               '*':testStr[i]:=Mal|
  753.               '/':testStr[i]:=Durch|
  754.               '^':testStr[i]:=Hoch|
  755.               '(':testStr[i]:=Bra|
  756.               ')':testStr[i]:=Ket
  757.             ELSE
  758.             END
  759.           END;
  760.           synOK:=SyntaxOK(testStr);
  761.           vD:=VarDef(testStr);
  762.           IF NOT vD THEN
  763.             fehlernummer:=32
  764.           ELSIF NOT synOK THEN
  765.             fehlernummer:=33
  766.           END
  767.         ELSE 
  768.           fehlernummer:=35   
  769.         END
  770.       ELSE
  771.         fehlernummer:=34
  772.       END;
  773.       IF fehlernummer#0  THEN
  774.         FOR i:=0 TO StrLength-1 DO formeln[nummer,i]:=0C END
  775.       END
  776.     ELSIF str[0]=0C THEN
  777.       fehlernummer:=31
  778.     ELSE
  779.       Error(ADR('DefFormel'),ADR('Es muss gelten:Len(str)<StrLength-2'))
  780.     END;
  781.     
  782.     IF (fehlernummer=0) AND korrekt THEN
  783.       IF NOT SetBrackets(testStr) THEN
  784.         fehlernummer:=36
  785.       END
  786.     END;
  787.     IF fehlernummer=0 THEN
  788.       Assign(formeln[nummer],testStr);
  789.       (*length[nummer]:=Length(testStr);*)
  790.       FOR zeichen:= CHR(FirstPos) TO CHR(FirstPos+soOft-1) DO
  791.         zahlenspeicherLong[nummer,zeichen]:=zahlenspeicherLong[0,zeichen];
  792.         zahlenspeicherFFP[nummer,zeichen]:=
  793.                                 Fieee(REAL(zahlenspeicherLong[0,zeichen]))
  794.       END
  795.     END;
  796.     RETURN fehlernummer;
  797.   END DefFormel;
  798. (**********************************************************************)
  799. BEGIN
  800.   Init;
  801. END Formelauswertung.mod
  802.  
  803.  
  804.